Libris Britannia 4/science library(b).zip/science library(b)/TECHNICA/AUTOCAD/H107.ZIP/RENAME.ZIP/RENAME.LSP

Lisp/Scheme | 1991-05-13 | 9KB | 288 lines

;;;   Rename.lsp
;;;   Copyright (C) 1991 by Autodesk, Inc.
;;;
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY.
;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF
;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;;   by Jan S. Yoder
;;;   May 1991
;;;
;;;--------------------------------------------------------------------------;
;;; DESCRIPTION
;;;
;;;   This routine allows you to rename multiple objects from a single symbol
;;;   table by specifying a name with wildcards (only "*" allowed at the
;;;   moment).  The interface is the same as that for AutoCAD's RENAME
;;;   command with the exception of allowing asteriks in the old and new
;;;   names.  A typical example follows.
;;;
;;;   Command: RENAME
;;;   RENAME: Block/Dimstyle/LAyer/LType/Style/Ucs/VIew/VPort: la
;;;   Old name: wall*
;;;   New name: fl_1_*
;;;
;;;   LAYER name changed from WALL1 to FL_1_1.
;;;   LAYER name changed from WALL2 to FL_1_2.
;;;   Command:
;;;
;;;   CAUTION:
;;;   The AutoCAD RENAME command is UNDEFINED by loading this routine.  It is
;;;   NOT REDEFINED!
;;;
;;;--------------------------------------------------------------------------;

(defun rename (/ rn_err rn_oe rn_oc tlold tlnew *STR_TOK*)
  (setq rn_ver "1.00")                ; Reset this local if you make a change.
  ;;
  ;; Internal error handler defined locally
  ;;

  (defun rn_err (s)                   ; If an error (such as CTRL-C) occurs
                                      ; while this command is active...
    (if (/= s "Function cancelled")
      (if (= s "quit / exit abort")
        (princ)
        (princ (strcat "\nError: " s))
      )
    )
    (command "undo" "end")
    (if rn_oe                         ; If an old error routine exists
      (setq *error* rn_oe)            ; then, reset it
    )
    (setvar "cmdecho" rn_oc)          ; Reset command echoing on error
    (princ)
  )

  ;;
  ;; Body of LLOAD function
  ;;

  (if *error*                         ; Set our new error handler
    (setq rn_oe *error* *error* rn_err)
    (setq *error* rn_err)
  )
  (setq rn_oc (getvar "cmdecho"))     ; Save current state of command echoing
  (setvar "cmdecho" 0)                ; Turn off command echoing
  (command "undo" "group")            ; Start an UNDO group

  (rename_all)

  (setvar "cmdecho" rn_oc)            ; Reset command echoing
  (princ)
)

(defun rename_all (/ which old new)
  (initget "Block Dimstyle LAyer LType Style Ucs VIew VPort")
  (setq which (getkword (strcat
    "\nRENAME " rn_ver ": Block/Dimstyle/LAyer/LType/Style/Ucs/VIew/VPort: "
  )))
  (if (or (null which) (= which ""))
    (exit)
    (setq which (strcase which nil))
  )
  (if (not (tblnext which T))
    (progn
      (princ (strcat "\nNo " (strcase which t) " names found."))
      (exit)
    )
  )
  (setq old (getstring "\nOld name: "))
  (if (or (null old) (= old ""))
    (exit)
    (setq old (strcase old nil))
  )
  (setq new (getstring "\nNew name: "))
  (if (or (null new) (= new ""))
    (exit)
    (setq new (strcase new nil))
  )
  (validate_old_new old new)
  (do_rename_loop which old new)
)

(defun do_rename_loop (which oldname newname / cont temp old new changed)
  (setq cont T
        temp (tblnext which T)
  )
  (if temp
    (while cont
      (if (wcmatch (setq old (cdr(assoc 2 temp))) oldname)
        (progn
          (setq new (setnew old newname))
          (command ".RENAME" which old new)
          (princ (strcat "\n" (strcase which nil) " name changed from "
                         old " to " new ". ")
          )
          (setq changed T)
        )
      )
      (if (not (setq temp (tblnext which nil)))
        (setq cont nil)
      )
    )
  )
  (if (not changed)
    (princ (strcat "\nNo matching " (strcase which t) " names found."))
  )
)

(defun setnew (old new)
  (setq oll (length tlold)
        j   0
  )
  (while (< j oll)
    (setq told (if (nth j tlold) (nth j tlold) ""))
    (setq tnew (if (nth j tlnew) (nth j tlnew) ""))
    (setq new (strrstr old told))
    (setq old (substr old 1 (- (strlen old) (strlen new) (strlen told))))
    (setq old (strcat old tnew new))
    (setq j (1+ j))
  )
  old
)

(defun validate_old_new (old new)
  (setq cont  T
        temp  (strtok old "*")
        tlold (list temp)
  )
  (while cont
    (setq temp (strtok nil "*"))
    (if (null temp)
      (setq cont nil)
      (setq tlold (append tlold (list temp)))
    )
  )
  (setq cont  T
        temp  (strtok new "*")
        tlnew (list temp)
  )
  (while cont
    (setq temp (strtok nil "*"))
    (if (null temp)
      (setq cont nil)
      (setq tlnew (append tlnew (list temp)))
    )
  )
  (if (/= (length tlold) (length tlnew))
    (progn
      (princ "\nChange specs do not match.")
      (exit)
    )
  )
)

;;;
;;; STRTOK -- Searches one string for tokens, which are separated by the
;;;           delimiters found in a second string.  String 1 contains the
;;;           string to be tokenized on the first call to strtok; thereafter
;;;           it should be nil for all subsequent calls to strtok for the
;;;           same string.
;;;
;;;           The first call to strtok returns the first token found in
;;;           the string, as a string, and sets the value of *STR_TOK*,
;;;           a global variable, to the remainder of the string passed in
;;;           as the first argument. Subsequent calls to srttok with a null
;;;           first argument will work through the string in *STR_TOK*
;;;           until no more tokens remain.
;;;
;;;           The separator string may be different on each call, if desired.
;;;
;;;           The following code fragment produces the output below.
;;;
;;;             (setq str "(defun strtok (_s1 _s2 / j s_l)") ;)
;;;             (print (strtok str " ()/"))
;;;             (while (setq temp (strtok nil " ()/")) (print temp))(princ)
;;;
;;;             "defun"
;;;             "strtok"
;;;             "_s1"
;;;             "_s2"
;;;             "j"
;;;             "s_l"
;;;
;;;           If the first argument is not a string and the original string
;;;           has been fully tokenized, -1 is returned.  If the second
;;;           argument is not a string, -2 is returned.
;;;
(defun strtok (_s1 _s2 / j sl s_l tok ch temp token)
  (if (or (= (type _s1) 'STR) (= (type *STR_TOK*) 'STR))
    (if (= (type _s2) 'STR)
      (if (> (setq sl (strlen (if _s1 _s1 *STR_TOK*))) 0)
        (progn
          (setq j 1)
          (repeat (strlen _s2)
            (setq s_l (if s_l (append s_l (list (substr _s2 j 1)))
                              (list (substr _s2 j 1))
                      )
                  j   (1+ j)
            )
          )
          (setq j 1 tok "")
          (while (and (<= j sl)
                   (not (member (setq ch (substr (if _s1 _s1 *STR_TOK*) j 1))
                              s_l)
                   )
                 )
            (setq tok (strcat tok ch)
                  j   (1+ j)
            )
          )
          (setq temp      (if _s1 _s1 *STR_TOK*)
                *STR_TOK* (substr temp (1+ j))
                token     (substr temp 1 (1- j))
          )
          (if (= (strlen token) 0)    ; If no token found
            (strtok nil _s2)          ; Recurse through sucessive separators
            token                     ; Return new token
          )
        )
        (setq *STR_TOK* nil)
      )
      -2
    )
    -1
  )
)
;;;
;;; STRRSTR -- Scans a string for the occurrence of a given substring.
;;;            Returns the remainder of the string
;;;
;;;           If both arguments are not strings -1 is returned.
;;;
(defun strrstr (_s1 _s2 / j sl sl2)
  (if (and (= (type _s1) 'STR)
           (= (type _s2) 'STR)
      )
    (progn
      (setq j   0
            sl  (strlen (eval _s1))
            sl2 (strlen _s2)
      )
      (while (< j sl)
        (if (= (substr (eval _s1) (setq j (1+ j)) 1)
               (substr _s2 1 1)
            )
          (if (= (substr (eval _s1) j sl2) _s2)
            (progn
              (setq _s1 (substr (eval _s1) (+ j sl2)))
              (setq j sl)
              (eval _s1)
            )
          )
        )
      )
    )
    -1
  )
)

(if (not undefined) (command "UNDEFINE" "RENAME"))
(setq undefined T)

(defun c:rename () (rename))
(princ "\n\tRENAME loaded.  Type RENAME to start program. \t")
(princ)